{*******************************************************************************
* The contents of this file are used with permission, subject to the Mozilla   *
* Public License Version 1.1 (the "License"); you may not use this file except *
* in compliance with the License. You may obtain a copy of the License at      *
* http://www.mozilla.org/MPL/                                                  *
*                                                                              *
* Software distributed under the License is distributed on an "AS IS" basis,   *
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *
* the specific language governing rights and limitations under the License.    *
*                                                                              *
* The Original Code is distributed as part of the "mediate" product and is     *
* Copyright (C) @home media limited. All Rights Reserved.                      *
*                                                                              *
* Email: support@athomemedia.co.uk                                             *
* Web:   http://www.athomemedia.co.uk                                          *
*******************************************************************************}

unit DirectShowVideo;

interface

uses Types, Windows, AHMTypes, DirectShowAudio, DirectXSprite, Direct3D9, D3DX9,
     DirectShow9, Colour, DirectShowRenderer;

const
  VMR_USER_ID = $6174686D; // ascii 'athm'
  VMR_NAME = '@home media video renderer';
  MIN_FAILED_PRESENT_FRAMES = -5; //
  MAX_FAILED_PRESENT_FRAMES = 5; // Maximum number of presentation failures allowed before we drop a frame

type
  TAHMDirectShowVideo = class(TAHMDirectShowAudio, IMediateVideoRenderer,
                              IVMRSurfaceAllocator9, IVMRImagePresenter9,
                              IVMRWindowlessControl9)
  private
    FPresentFrameFails: Integer;
    FPresentFrameSkips: Integer;
    FPresentFrameCurr: Integer;
    FPresentFrameMax: Integer;
    FVideoSprite: TAHMDXSprite;
    FBasicVideo: IBasicVideo2;
    FSurfaces: array of IDirect3DSurface9;
    FRenderSurface: IDirect3DSurface9;
    FVideoAspect: Single;
    FVideoRenderer: TAHMVideoRenderer;
    FFullscreen: Boolean;
  protected
    FPresentTargetRect: TAHMRectF;
    FVideoWidth: Integer;
    FVideoHeight: Integer;
    FVMR: IBaseFilter; // Video Mixing Renderer
    FVMRSurfAllocNotify: IVMRSurfaceAllocatorNotify9;
    procedure ReleaseSurfaces;
    function ValidateGraph: Boolean;
    procedure ScaleVideo;
    function FixAspectRatio(var Rect: TAHMRectF): Boolean;
    procedure CustomGraphConfiguration; override;
    procedure CustomGraphCompletion; override;
    procedure CustomGraphShutdown; override;
  public
    constructor Create;
    destructor Destroy; override;
    property Fullscreen: Boolean read FFullscreen write FFullscreen;
    procedure OnLostDevice;
    procedure OnResetDevice;
    function Play: Boolean; override;
    procedure RenderFrame(Rect: TAHMRectF; Shade: TAHMCanvasShade; Gamma: TAHMCanvasColour;
                          XScale, YScale: Single; XFlip, YFlip: Boolean);
    // IMediateVideoRenderer interface methods
    function InitialiseRenderer(Info: PMediateRendererSetup): HResult; stdcall;
    function TerminateRenderer: HResult; stdcall;
    function PresentMediateFrame(Frame: IMediaSample): HResult; stdcall;
    // IVMRSurfaceAllocator9 interface methods
    function InitializeDevice(dwUserID: DWORD; lpAllocInfo: PVMR9AllocationInfo;
      var lpNumBuffers: DWORD): HResult; stdcall;
    function TerminateDevice(dwID: DWORD): HResult; stdcall;
    function GetSurface(dwUserID: DWORD; SurfaceIndex: DWORD; SurfaceFlags: DWORD;
      out lplpSurface: IDirect3DSurface9): HResult; stdcall;
    function AdviseNotify(lpIVMRSurfAllocNotify: IVMRSurfaceAllocatorNotify9): HResult; stdcall;
    // IVMRImagePresenter9 interface methods
    function StartPresenting(dwUserID: DWORD): HResult; stdcall;
    function StopPresenting(dwUserID: DWORD): HResult; stdcall;
    function PresentImage(dwUserID: DWORD; lpPresInfo: PVMR9PresentationInfo): HResult; stdcall;
    // IVMRWindowlessControl9 interface methods
    function GetNativeVideoSize(out lpWidth, lpHeight, lpARWidth, lpARHeigh: LongInt): HResult; stdcall;
    function GetMinIdealVideoSize(out lpWidth, lpHeight: LongInt): HResult; stdcall;
    function GetMaxIdealVideoSize(out lpWidth, lpHeight: LongInt): HResult; stdcall;
    function SetVideoPosition(lpSRCRect, lpDSTRect: PRECT): HResult; stdcall;
    function GetVideoPosition(out lpSRCRect, lpDSTRect: TRECT): HResult; stdcall;
    function GetAspectRatioMode(out lpAspectRatioMode: TVMR9AspectRatioMode): HResult; stdcall;
    function SetAspectRatioMode(AspectRatioMode: TVMR9AspectRatioMode): HResult; stdcall;
    function SetVideoClippingWindow(hwnd: HWND): HResult; stdcall;
    function RepaintVideo(hwnd: HWND; hdc: HDC): HResult; stdcall;
    function DisplayModeChanged: HResult; stdcall;
    function GetCurrentImage(out lpDib: PBYTE): HResult; stdcall;
    function SetBorderColor(Clr: COLORREF): HResult; stdcall;
    function GetBorderColor(out lpClr: COLORREF): HResult; stdcall;
  end;

implementation

uses Classes, SysUtils, ActiveX, DirectShowHelper, DirectShowManager,
     DirectXHelper, DXErr9, Timing, Logging, ApplicationManager, DSUtil,
     Canvas;

//----------------------------------------------------------------------------//

constructor TAHMDirectShowVideo.Create;
begin
  inherited Create;

  // Create sprite object to use for rendering video frames
  FVideoSprite := DirectXInstance.SpriteManager.CreateSprite;

  // Determine maximum video frame skipping & video renderer
  FPresentFrameMax := ApplicationManagerInstance.PreferencesManager.VideoThrottle;
  FVideoRenderer := ApplicationManagerInstance.PreferencesManager.VideoRenderer;
end;

destructor TAHMDirectShowVideo.Destroy;
begin
  // Ensure we delete any directX surfaces when destroyed
  ReleaseSurfaces;
  FVideoSprite.Free;

  inherited Destroy;
end;

procedure TAHMDirectShowVideo.OnLostDevice;
begin
  // We only need to handle lost device scenarios when using VMR9
  if FVideoRenderer <> vrVMR9 then Exit;

  // Inform VMR9 our device has been lost and release DEFAULT resources
  FVMRSurfAllocNotify.NotifyEvent(EC_FULLSCREEN_LOST, 0, 0);
  FVMRSurfAllocNotify.NotifyEvent(EC_DEVICE_LOST, 0, 0);
  FVMRSurfAllocNotify.NotifyEvent(EC_NEED_RESTART, 0, 0);
  ReleaseSurfaces;
end;

procedure TAHMDirectShowVideo.OnResetDevice;
var
  hr: HRESULT;
begin
  // We only need to recover lost device scenarios when using VMR9
  if FVideoRenderer <> vrVMR9 then Exit;

  // Inform the allocator that the display device has been reset
  with DirectXInstance do
    hr := FVMRSurfAllocNotify.ChangeD3DDevice(DisplayDevice, DisplayHandle);
  if hr <> S_OK then
    LogWarn('Failed to reset DirectShow VMR custom display device properties');
end;

procedure TAHMDirectShowVideo.ReleaseSurfaces;
var
  i: Integer;
begin
  // We only need to release surfaces when using VMR9
  if FVideoRenderer <> vrVMR9 then Exit;

  FObjectLock.Enter;
  try
    // Release our rendering surfaces
    FRenderSurface := nil;

    // Release all directx surfaces
    for i := 0 to Pred(Length(FSurfaces)) do
      FSurfaces[i] := nil;
  finally
    FObjectLock.Leave;
  end;
end;

procedure TAHMDirectShowVideo.CustomGraphConfiguration;
var
  VMR9FilterConfig: IVMRFilterConfig9;
  MVRFilterConfig: IMediateVideoConfig;
  hr: HResult;
begin
  // Add standard audio renderer filters
  inherited;

  // Create Video Renderer instance
  DirectShowInstance.LastVideoError := dvNoVMR;
  case FVideoRenderer of
    vrVMR9: FVMR := FGraph.CreateFilter(CLSID_VideoMixingRenderer9);
    vrMVR: FVMR := TAHMDXVideoRenderer.Create(VMR_NAME, nil, hr);
    else FVMR := nil;
  end;
  if FVMR = nil then
    raise EDirectShowException.Create('Failed to create DirectShow video mixing renderer');

  // Add VMR filter to the filter graph
  if not FGraph.AddFilter(FVMR, VMR_NAME) then
    raise EDirectShowException.Create('Failed to add VMR filter to DirectShow filter graph');

  // Configure VMR9 renderless or MVR rendering mode as required
  if FVideoRenderer = vrVMR9 then
  begin
    // Query VMR for its filter configuration interface to set renderless mode
    if FVMR.QueryInterface(IID_IVMRFilterConfig9, VMR9FilterConfig) <> S_OK then
      raise EDirectShowException.Create('Failed to obtain DirectShow VMR9 filter configuration interface');
    if VMR9FilterConfig.SetRenderingMode(VMR9Mode_Renderless) <> S_OK then
      raise EDirectShowException.Create('Failed to set DirectShow VMR9 filter to renderless mode');

    // Query VMR for its surface allocator notify interface to set custom presenter
    if FVMR.QueryInterface(IID_IVMRSurfaceAllocatorNotify9, FVMRSurfAllocNotify) <> S_OK then
      raise EDirectShowException.Create('Failed to obtain DirectShow VMR surface allocator notify interface');

    // Connect our custom allocator presenter object to VMR for renderless mode
    if FVMRSurfAllocNotify.AdviseSurfaceAllocator(VMR_USER_ID, Self) <> S_OK then
      raise EDirectShowException.Create('Failed to set DirectShow custom surface allocator object');
    if Self.AdviseNotify(FVMRSurfAllocNotify) <> S_OK then
      raise EDirectShowException.Create('Failed to set DirectShow VMR custom display device properties');
  end
  else
  begin
    // Query MVR for its filter configuration interface to setup rendering
    if FVMR.QueryInterface(IID_IMediateVideoConfig, MVRFilterConfig) <> S_OK then
      raise EDirectShowException.Create('Failed to obtain DirectShow MVR filter configuration interface');
    if MVRFilterConfig.ConnectRenderer(Self) <> S_OK then
      raise EDirectShowException.Create('Failed to connect renderer to DirectShow MVR filter');
  end;
end;

procedure TAHMDirectShowVideo.CustomGraphCompletion;
begin
  // Add standard interfaces for audio & seeking
  inherited;

  // Query filter graph manager for additional video control interfaces
  if not FGraph.FindInterface(IID_IBasicVideo2, FBasicVideo) then
    raise EDirectShowException.Create('Failed to obtain DirectShow basic video interface');

  // Check that VMR renderer has been properly incorporated into graph
  if not ValidateGraph then
    raise EDirectShowException.Create('Failed to build VMR compatible render graph for file (check codecs)');

  // Determine video dimensions & aspect ratio
  ScaleVideo;
end;

procedure TAHMDirectShowVideo.CustomGraphShutdown;
begin
  // Release standard interfaces for audio & seeking
  inherited;

  // Release video specific direct show COM object & interfaces
  FVMRSurfAllocNotify := nil;
  FVMR := nil;
  FBasicVideo := nil;
end;

function TAHMDirectShowVideo.ValidateGraph: Boolean;
var
  hr: HRESULT;
  EnumPins: IEnumPins;
  InPin, ConPin: IPin;
  PinDir: TPinDirection;
begin
  // Default result - VMR not supported by rendered graph
  Result := False;
  LogInfo('Validating VMR renderer filter is connected in filter graph');

  // Validate our constructed graph is correctly configured for VMR
  if FVMR <> nil then
  begin
    // Get an enumeration of all VMR filter pins
    hr := FVMR.EnumPins(EnumPins);
    if hr <> S_OK then
    begin
      LogWarn('Failed to enumerate pins on VMR filter: ' + DSGetErrorString9(hr));
      Exit;
    end;

    // Step through pin enumeration looking for input pins
    while (EnumPins.Next(1, InPin, nil) = S_OK) do
    begin
      // What direction is this pin?
      hr := InPin.QueryDirection(PinDir);
      if hr <> S_OK then
      begin
        LogWarn('Failed to determine pin direction on VMR filter pin: ' + DSGetErrorString9(hr));
        Exit;
      end;

      // If it's an input pin, is it connected to anything?
      if PinDir = PINDIR_INPUT then
      begin
        hr := InPin.ConnectedTo(ConPin);
        if hr = S_OK then
        begin
          // Cool, we have at least one input pin connected, so we can assume that
          // our VMR filter has been successfully incorporated into the graph
          Result := True;
          Exit;
        end
        else if hr <> VFW_E_NOT_CONNECTED then
        begin
          LogWarn('Failed to determine pin connections on VMR filter pin: ' + DSGetErrorString9(hr));
          Exit;
        end;
      end;
    end;
  end;
  LogInfo('Validated VMR renderer filter connections successfully');
end;

procedure TAHMDirectShowVideo.ScaleVideo;
var
  AspectX, AspectY: LongInt;
  VideoWidth, VideoHeight: Integer;
  hr: HRESULT;
begin
  if FBasicVideo <> nil then
  begin
    // Check whether video has alternate dimensions we should use
    hr := FBasicVideo.GetVideoSize(VideoWidth, VideoHeight);
    if hr <> S_OK then
      LogInfo('Failed to determine video dimensions from media: ' + DSGetErrorString9(hr))
    else
    begin
      LogInfo('Video source dimensions: ' + IntToStr(VideoWidth) + 'x' +
                                            IntToStr(VideoHeight) + ' pixels');
      FVideoWidth := VideoWidth;
      FVideoHeight := VideoHeight;
    end;

    // Does this video have a preferred aspect ratio?
    hr := FBasicVideo.GetPreferredAspectRatio(AspectX, AspectY);
    if hr = S_OK then
    begin
      if AspectY <> 0 then
      begin
        FVideoAspect := AspectX / AspectY;
        LogInfo('Using preferred video aspect ratio of ' + IntToStr(AspectX) + ':' + IntToStr(AspectY));
        Exit;
      end
      else
        // Ignore zero aspect ratio
        LogInfo('Ignoring invalid preferred video aspect ratio');
    end
    else
      // No preferred aspect ratio
      LogInfo('Video does not have a preferred aspect ratio');
  end;

  // If no valid preferred aspect ratio then calculate it manually
  if (FVideoAspect = 0.0) and (FVideoWidth > 0) and (FVideoHeight > 0) then
     FVideoAspect := FVideoWidth / FVideoHeight;
end;

function TAHMDirectShowVideo.FixAspectRatio(var Rect: TAHMRectF): Boolean;
var
  VWidth, VHeight, DWidth, DHeight: Single;
begin
  // Set default result - invalid dimensions
  Result := True;

  // Calculate destination rectangle dimensions & validate
  DWidth := Rect.Width;
  DHeight := Rect.Height;
  if (DWidth <= 0) or (DHeight <= 0) then Exit;

  // Tweak target rectangle if we have a stored video aspect ratio
  if (FVideoWidth > 0) and (FVideoHeight > 0) and (FVideoAspect <> 0.0) then
  begin
    // Try to stretch video vertically then horizontally to fit dest. rect
    VWidth := DWidth;
    VHeight := DWidth / FVideoAspect;
    if VHeight > DHeight then
    begin
      VHeight := DHeight;
      VWidth := DHeight * FVideoAspect;
    end;

    // Calculate centred destination rectangle for rendering surface
    with Rect do
    begin
      if VWidth < DWidth then X := X + ((DWidth - VWidth) / 2);
      if VHeight < DHeight then Y := Y + ((DHeight - VHeight) / 2);
      Width := VWidth;
      Height := VHeight;
    end;
  end;

  // Record video render target position for later reference
  FPresentTargetRect := Rect;
end;

function TAHMDirectShowVideo.Play: Boolean;
begin
  // Use inherited graph control behaviour
  Result := inherited Play;

  // Reset our count of failed frame presentations
  FPresentFrameFails := 0;
  FPresentFrameSkips := 0;
  FPresentFrameCurr := 0;
end;

procedure TAHMDirectShowVideo.RenderFrame(Rect: TAHMRectF; Shade: TAHMCanvasShade;
                                          Gamma: TAHMCanvasColour; XScale, YScale: Single;
                                          XFlip, YFlip: Boolean);
begin
  FObjectLock.Enter;
  try
    // Check we have a surface to present
    if (FVideoRenderer = vrVMR9) and not Assigned(FRenderSurface) then
    begin
      LogWarn('Invalid VMR9 surface when trying to render video frame');
      Exit;
    end;

    // Blit presented surface to backbuffer
    FixAspectRatio(Rect);

    DirectXInstance.DrawSprite(FVideoSprite, FVideoSprite.SourceRect, Rect,
                               Shade, Gamma, XScale, YScale, XFlip, YFlip);
  finally
    FObjectLock.Leave;
  end;
end;

//----------------------------------------------------------------------------//
// IMediateRenderer interface methods
//----------------------------------------------------------------------------//

function TAHMDirectShowVideo.InitialiseRenderer(Info: PMediateRendererSetup): HResult;
var
  DXTexture: IDirect3DTexture9;
begin
  // Called by mediate renderer when it needs us to allocate textures. May be
  // called repeatedly if requested format is not acceptable to upstream
  // decoders or filters, in which case TerminateRenderer is called before
  // invoking this method with an alternate texture format
  LogDebug('InitialiseRenderer method called for MVR renderer');
  if Info = nil then
  begin
    Result := E_POINTER;
    Exit;
  end
  else Result := E_FAIL;

  // Store video dimensions
  FVideoWidth := Info.Width;
  FVideoHeight := Info.Height;
  LogInfo('InitialiseRenderer setup info requested dimensions: ' +
          IntToStr(FVideoWidth) + ' x ' + IntToStr(FVideoHeight));
  LogInfo('InitialiseRenderer setup info requested surface format: ' +
          DirectXInstance.FormatToString(Info.Format));

  // Now create a custom sprite texture surface using same format as MVR,
  // but held in the DEFAULT pool so we can lock the texture later
  with FVideoSprite do
  begin
    SetDimensions(Info.Width, Info.Height);
    DXTexture := AllocateVideoTexture(Info.Format, D3DPOOL_DEFAULT);

    if DXTexture <> nil then
    begin
      // Clear texture to avoid video glitch on playback
      ClearTexture;

      // Success, surfaces allocated successfully
      LogInfo('InitialiseRenderer successfully created private rendering texture');
      Result := S_OK;
     end;
  end;
end;

function TAHMDirectShowVideo.TerminateRenderer: HResult; stdcall;
begin
  // Called by MVR when it has finished with the display device. Since our
  // rendering texture is free'd when we destroy the object we don't do it here
  Result := S_OK;
end;

function TAHMDirectShowVideo.PresentMediateFrame(Frame: IMediaSample): HResult;
var
  hr: HRESULT;
  TxLock: TD3DLockedRect;
  Source, Destination: PByte;
  ByteWidth, i: Integer;
begin
  // Validate passed presentation parameters
  if Frame = nil then
  begin
    Result := E_POINTER;
    Exit;
  end
  else
    Result := S_OK;

  // We always update our private texture so we have the latest frame available
  // when we get to render - this reduces apparent frame jerkiness to user.
  // Note that we also aquire a lock on the texture so that we don't try to
  // update and render it at the same time, which would result in tearing
  FObjectLock.Enter;
  try
    with FVideoSprite do
    begin
      if Texture = nil then
      begin
        LogInfo('Nil video sprite texture - can''t render video frame');
        Exit;
      end;

      // Lock texture and blit frame
      hr := Texture.LockRect(0, TxLock, nil, D3DLOCK_DISCARD);
      if hr = D3D_OK then
      begin
        // Now we can copy lines from source sample to destination surface
        Frame.GetPointer(Source);
        Destination := TxLock.pBits;
        ByteWidth := Round(Width * 4);

        // Media sample is inverted vertically, so point to bottom row
        Inc(Destination, (Height - 1) * TxLock.Pitch);

        // Copy each line individually to account for texture padding
        for i := 0 to Pred(Height) do
        begin
          Move(Source^, Destination^, ByteWidth);
          Dec(Destination, TxLock.Pitch);
          Inc(Source, ByteWidth);
        end;

        // Finished copying, unlock the texture
        Texture.UnlockRect(0);
      end
      else
        LogInfo('Failed to lock video texture for blitting frame: ' + DXGetErrorString9(hr));
    end;
  finally
    FObjectLock.Leave;
  end;

  // We need to check if we should render or skip this frame in the UI layer
  if FPresentFrameSkips > FPresentFrameCurr then
  begin
    // Skipping, so increment count of skipped frames
    Inc(FPresentFrameCurr)
  end
  else
  begin
    // Rendering, reset our frame number
    FPresentFrameCurr := 0;

    // Do we need to regulate our frame rendering interval?
    if FPresentFrameFails > MAX_FAILED_PRESENT_FRAMES then
    begin
      FPresentFrameFails := 0;
      Inc(FPresentFrameSkips);
    end
    else if FPresentFrameFails < MIN_FAILED_PRESENT_FRAMES then
    begin
      FPresentFrameFails := 0;
      Dec(FPresentFrameSkips);
    end;

    // Clamp our maximum & minimum frame skipping
    if FPresentFrameSkips < 0 then FPresentFrameSkips := 0;
    if FPresentFrameSkips > FPresentFrameMax then FPresentFrameSkips := FPresentFrameMax;

    // Submit a request to render this video frame and check it's accepted
    if TimerInstance.RequestRender then Dec(FPresentFrameFails)
                                   else Inc(FPresentFrameFails);
  end;
end;

//----------------------------------------------------------------------------//
// IVMRSurfaceAllocator9 interface methods
//----------------------------------------------------------------------------//

function TAHMDirectShowVideo.InitializeDevice(dwUserID: DWORD; lpAllocInfo: PVMR9AllocationInfo;
  var lpNumBuffers: DWORD): HResult;
var
  hr: HRESULT;
  sFmt: String;
  TxWidth, TxHeight: DWORD;
  OrigWidth, OrigHeight: DWORD;
  DXTexture: IDirect3DTexture9;
begin
  // Called by VMR9 when it needs our allocator-presenter to allocate surface(s)
  // May be called repeatedly if requested surface format is not acceptable
  // to upstream decoders or filters, in which case TerminateDevice is called
  // before invoking this method with an alternate surface format
  LogDebug('InitializeDevice method called for custom VMR Allocator Presenter');
  if (lpNumBuffers = 0) then
  begin
    Result := E_POINTER;
    Exit;
  end
  else Result := E_FAIL;

  // Store video native size & aspect ratio in case we can't query from IBasicVideo
  FVideoWidth := lpAllocInfo.szNativeSize.cx;
  FVideoHeight := lpAllocInfo.szNativeSize.cy;
  if (lpAllocInfo.szAspectRatio.cx > 0) and (lpAllocInfo.szAspectRatio.cy > 0) then
    FVideoAspect := lpAllocInfo.szAspectRatio.cx / lpAllocInfo.szAspectRatio.cy
  else
    FVideoAspect := 0.0;
  LogInfo('InitializeDevice allocation info requested dimensions: ' +
          IntToStr(FVideoWidth) + ' x ' + IntToStr(FVideoHeight));

  // Scale surface size to power of 2 multiple if required by gfx h/w
  OrigWidth := lpAllocInfo.dwWidth; OrigHeight := lpAllocInfo.dwHeight;
  if DirectXInstance.Power2Textures then
  begin
    TxWidth := 1; TxHeight := 1;
    while TxWidth < lpAllocInfo.dwWidth do TxWidth := TxWidth shl 1;
    while TxHeight < lpAllocInfo.dwHeight do TxHeight := TxHeight shl 1;
    lpAllocInfo.dwWidth := TxWidth; lpAllocInfo.dwHeight := TxHeight;
  end;

  // Release any existing surfaces and resize array to store number requested
  ReleaseSurfaces;
  SetLength(FSurfaces, lpNumBuffers);

  // Tweak allocation flags so that we create a texture surface - this ensures
  // format will match our private texture later so we can easily copy to it
  LogInfo('InitializeDevice allocation info requested flags: ' + IntToStr(lpAllocInfo.dwFlags));
  lpAllocInfo.dwFlags := VMR9AllocFlag_TextureSurface;
  sFmt := DirectXInstance.FormatToString(lpAllocInfo.Format);

  LogInfo('InitializeDevice allocation info requested surface format: ' +
          DirectXInstance.FormatToString(lpAllocInfo.Format));
  LogInfo('InitializeDevice allocation info requested surface pool: ' +
          DirectXInstance.PoolToString(lpAllocInfo.Pool));

  // Use surface allocation helper to create video presentation surfaces for us.
  // We force use of system memory pool so we can use UpdateSurface later -
  // although this doesn't support colour conversion our private texture will
  // now be in the same format so this isn't necessary. Also VMR9 doesn't like
  // releasing default pool surfaces when we lose display device
  lpAllocInfo.Pool := D3DPOOL_SYSTEMMEM;

  // Allocate video surfaces
  hr := FVMRSurfAllocNotify.AllocateSurfaceHelper(lpAllocInfo, lpNumBuffers, FSurfaces[0]);
  if hr <> S_OK then
  begin
    LogInfo('Failed to create presentation ' + sFmt + ' surfaces for VMR9: ' + DXGetErrorString9(hr));
    Result := hr;
    Exit;
  end;
  LogInfo('InitializeDevice successfully created VMR9 rendering surfaces');

  // Now create a custom sprite texture surface using same format as VMR9,
  // but held in the DEFAULT pool so blit to it later using UpdateSurface
  with FVideoSprite do
  begin
    SetDimensions(OrigWidth, OrigHeight);
    DXTexture := AllocateVideoTexture(lpAllocInfo.Format, D3DPOOL_DEFAULT);

    if DXTexture <> nil then
    begin
      // Get corresponding surface and clear to avoid video glitch on playback
      hr := DXTexture.GetSurfaceLevel(0, FRenderSurface);
      if hr <> D3D_OK then
        LogWarn('Failed to retrieve video surface from sprite texture: ' + DXGetErrorString9(hr))
      else
        ClearTexture;

      // Success, surfaces allocated successfully
      LogInfo('InitializeDevice successfully created private rendering texture');
      Result := S_OK;
     end;
  end;
end;

function TAHMDirectShowVideo.TerminateDevice(dwID: DWORD): HResult;
begin
  // Called by VMR9 when it has finished with the display device. Since our
  // display device is used for rendering elsewhere, here we'll just free
  // our surfaces allocated earlier
  ReleaseSurfaces;
  Result := S_OK;
end;

function TAHMDirectShowVideo.GetSurface(dwUserID: DWORD; SurfaceIndex: DWORD; SurfaceFlags: DWORD;
  out lplpSurface: IDirect3DSurface9): HResult;
begin
  // Called by VMR9 to retrieve a pointer to one of our surfaces created earlier
  if @lplpSurface = nil then
  begin
    Result := E_POINTER;
    Exit;
  end
  else Result := E_FAIL;

  // Ensure requested surface index got created earlier
  if SurfaceIndex >= Cardinal(Length(FSurfaces)) then Exit;

  FObjectLock.Enter;
  try
    try
      lplpSurface := FSurfaces[SurfaceIndex];
      if Assigned(lplpSurface) then Result := S_OK;
    except
      on E: Exception do LogError('Unexpected exception raised whilst getting DirectShow surface: ' + E.Message);
    end;
  finally
    FObjectLock.Leave;
  end;
end;

function TAHMDirectShowVideo.AdviseNotify(lpIVMRSurfAllocNotify: IVMRSurfaceAllocatorNotify9): HResult;
begin
  // Tell the VMR to use our own Direct3D device and monitor
  with DirectXInstance do
    Result := lpIVMRSurfAllocNotify.SetD3DDevice(DisplayDevice, DisplayHandle);
  if Result <> S_OK then Result := E_FAIL;
end;

//----------------------------------------------------------------------------//
// IVMRImagePresenter9 interface methods
//----------------------------------------------------------------------------//

function TAHMDirectShowVideo.StartPresenting(dwUserID: DWORD): HResult;
begin
  // Called by the VMR just as the media starts playing, unless we pause before playing
  // in which case the Present method is fired before this - which makes this method
  // pretty useless really so we don't do anything special here
  Result := S_OK;
end;

function TAHMDirectShowVideo.StopPresenting(dwUserID: DWORD): HResult;
begin
  // Called by the VMR just after the media finishes playing. We can perform any
  // required cleanup steps in this method
  Result := S_OK;
end;

function TAHMDirectShowVideo.PresentImage(dwUserID: DWORD; lpPresInfo: PVMR9PresentationInfo): HResult;
var
  hr: HRESULT;
  DestRect: TRect;
begin
  // Validate passed presentation parameters
  if (lpPresInfo = nil) or (lpPresInfo.lpSurf = nil) then
  begin
    Result := E_POINTER;
    Exit;
  end
  else
    Result := S_OK;

  try
  // We always update our private texture so we have the latest frame available
  // when we get to render - this reduces apparent frame jerkiness to user.
  // Note that we also aquire a lock on the texture so that we don't try to
  // update and render it at the same time, which would result in tearing
  FObjectLock.Enter;
  try
    with FVideoSprite do
    begin
      if Texture = nil then
        LogInfo('Nil video sprite texture - can''t render video frame')
      else if FRenderSurface = nil then
        LogInfo('Invalid surface when blitting presented video frame')
      else
      begin
        // Get sprite destination area (may be bigger than requested on some H/W)
        DestRect := GetNativeRect(Bounds);

        // Blit this video frame onto our rendering surface for drawing at our
        // leisure - allows us to render multiple videos at different framerates
        if Assigned(DirectXInstance.DisplayDevice) then
        begin
          hr := DirectXInstance.DisplayDevice.UpdateSurface(lpPresInfo.lpSurf, @DestRect, FRenderSurface, nil);
          if hr <> D3D_OK then
            LogInfo('Failed to blit video frame to render surface: ' + DXGetErrorString9(hr));
        end;
      end;
    end;
  finally
    FObjectLock.Leave;
  end;

  // We need to check if we should render or skip this frame in the UI layer
  if FPresentFrameSkips > FPresentFrameCurr then
  begin
    // Skipping, so increment count of skipped frames
    Inc(FPresentFrameCurr)
  end
  else
  begin
    // Rendering, reset our frame number
    FPresentFrameCurr := 0;

    // Do we need to regulate our frame rendering interval?
    if FPresentFrameFails > MAX_FAILED_PRESENT_FRAMES then
    begin
      FPresentFrameFails := 0;
      Inc(FPresentFrameSkips);
    end
    else if FPresentFrameFails < MIN_FAILED_PRESENT_FRAMES then
    begin
      FPresentFrameFails := 0;
      Dec(FPresentFrameSkips);
    end;

    // Clamp our maximum & minimum frame skipping
    if FPresentFrameSkips < 0 then FPresentFrameSkips := 0;
    if FPresentFrameSkips > FPresentFrameMax then FPresentFrameSkips := FPresentFrameMax;

    // Submit a request to render this video frame and check it's accepted
    if TimerInstance.RequestRender then Dec(FPresentFrameFails)
                                   else Inc(FPresentFrameFails);
  end;

  except
    on E: Exception do
      LogError('DirectShow VMR9 failure: ' + E.Message); // let directshow carry on & see what happens...
  end;
end;

//----------------------------------------------------------------------------//
// IVMRWindowlessControl9 interface methods
//----------------------------------------------------------------------------//

function TAHMDirectShowVideo.GetNativeVideoSize(out lpWidth, lpHeight, lpARWidth, lpARHeigh: LongInt): HResult;
begin
  // Return native size and aspect ratio of current video file
  lpWidth := FVideoWidth;
  lpHeight := FVideoHeight;
  lpARWidth := FVideoWidth;
  lpARWidth := FVideoHeight;
  Result := S_OK;
end;

function TAHMDirectShowVideo.GetMinIdealVideoSize(out lpWidth, lpHeight: LongInt): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: GetMinIdealVideoSize');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.GetMaxIdealVideoSize(out lpWidth, lpHeight: LongInt): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: GetMaxIdealVideoSize');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.SetVideoPosition(lpSRCRect, lpDSTRect: PRECT): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: SetVideoPosition');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.GetVideoPosition(out lpSRCRect, lpDSTRect: TRECT): HResult;
var
  SourceRect: TRect;
begin
  // Return video source and destination rectangles
  SourceRect := Rect(0, 0, FVideoWidth, FVideoHeight);
  lpSRCRect := SourceRect;
  lpDSTRect := GetRoundedNativeRect(FPresentTargetRect);
  Result := S_OK;
end;

function TAHMDirectShowVideo.GetAspectRatioMode(out lpAspectRatioMode: TVMR9AspectRatioMode): HResult;
begin
  // We're not attempting to preserve aspect ratio when we render
  lpAspectRatioMode := VMR9ARMode_None;
  Result := S_OK;
end;

function TAHMDirectShowVideo.SetAspectRatioMode(AspectRatioMode: TVMR9AspectRatioMode): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: SetAspectRatioMode');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.SetVideoClippingWindow(hwnd: HWND): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: SetVideoClippingWindow');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.RepaintVideo(hwnd: HWND; hdc: HDC): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: RepaintVideo');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.DisplayModeChanged: HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: DisplayModeChanged');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.GetCurrentImage(out lpDib: PBYTE): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: GetCurrentImage');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.SetBorderColor(Clr: COLORREF): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: SetBorderColor');
  Result := E_NOTIMPL;
end;

function TAHMDirectShowVideo.GetBorderColor(out lpClr: COLORREF): HResult;
begin
  LogError('Unsupported DirectShow IVMRWindowlessControl9 method: GetBorderColor');
  Result := E_NOTIMPL;
end;



end.
